;;;; -*- Mode: Lisp; Package: :dreaming-tree -*-
;;;;
;;;; geometry.lisp
;;;;

(in-package :dreaming-tree)

(defparameter *debug-update-pass* nil)

;;;; -*- Implementing a scene manager -*-

;;; Spatial ;;;

(defmethod print-slots ((s spatial))
  '(o name))

(defmethod initialize-data ((s spatial) r)
  (declare (ignore s r))
  t)

(defmethod initialize-data :before ((s spatial) r)
  (setf (view s) r))

(defmethod center ((s spatial))
  (transform-b (slot-value s 'transformation)))

(defmethod update-bound-state ((s spatial))
  (when *debug-update-pass* (format t "Update-bound-state: ~A~%" (name s)))
  (update-world-bound s)
  (propagate-bound-to-root s))

(defmethod update-geometric-state ((s spatial) app-time initiator-p)
  (when *debug-update-pass* (format t "Update-geometric-state: ~A~%" (name s)))
  (update-world-data s app-time)
  (update-world-bound s)
  (when initiator-p
    (propagate-bound-to-root s)))

(defmethod propagate-state-from-root ((s spatial) states lights)
  (when (part-of s)
    (propagate-state-from-root (part-of s) states lights))
  (push-state s states lights))
			 
(defmethod update-world-data ((s spatial) app-time)
  (when *debug-update-pass* (format t "Update-world-data: ~A~%" (name s)))
  (update-controllers (controllers s) s app-time))

(defmethod propagate-bound-to-root ((s spatial))
  (when *debug-update-pass* (format t "Propagate-bound-to-root: ~A~%" (name s)))
  (with-slots (part-of) s
    (when part-of
      (update-world-bound part-of)
      (propagate-bound-to-root part-of))))

(defmethod move ((s spatial) x y z)
  (with-slots ((m_l transformation)) s
    (set-position s (m+ (transform-b m_l) (make-vector x y z)))))

(defmethod move-to ((s spatial) x y z)
  (set-position s (make-vector x y z)))

(defmethod set-x-position ((s spatial) x)
  (with-slots ((m_l transformation)) s
    (let ((pos (transform-b m_l)))
      (move-to s x (y pos) (z pos)))))

(defmethod set-y-position ((s spatial) y)
  (with-slots ((m_l transformation)) s
    (let ((pos (transform-b m_l)))
      (move-to s (x pos) y (z pos)))))

(defmethod set-z-position ((s spatial) z)
  (with-slots ((m_l transformation)) s
    (let ((pos (transform-b m_l)))
      (move-to s (x pos) (y pos) z))))

(defmethod set-position ((s spatial) pos)
  (with-slots ((m_l transformation)) s
    (set-translation m_l pos)))

(defmethod rotate-by ((s spatial) &key (rx 0.0) (ry 0.0) (rz 0.0) (radians t))
  (xyz-rotate (transformation s) rx ry rz radians))

(defmethod scale-by ((s spatial) &key (sx 1.0) (sy 1.0) (sz 1.0))
    (set-scale (transformation s) (m* (transform-s (transformation s))
				      (make-vector sx sy sz))))

(defmethod set-attribute-value ((s spatial) attribute value)
  (case attribute
    (x (set-x-position s (read-typed-attribute-value value 'single-float)))
    (y (set-y-position s (read-typed-attribute-value value 'single-float)))
    (z (set-z-position s (read-typed-attribute-value value 'single-float)))))

;;; Node ;;;

(defun make-node (&key (named "untitled") (x 0.0) (y 0.0) (z 0.0))
  (let ((node (make-instance 'node :name named)))
    (move-to node x y z)
    node))

(defmethod draw ((n node))
  ) ; Used for setting global render states/effects?

(defmethod initialize-data ((n node) r)
  (dolist (child (children n))
    (initialize-data child r)))

(defmethod find-child-named (name (s spatial))
  (if (string-equal (name s) name)
      s
      nil))

(defmethod find-child-named (name (n node))
  (if (string-equal (name n) name)
      n
      (find-child-named name (children n))))

(defmethod find-child-named (name (l list))
  (cond ((null l) nil)
	(t (or (find-child-named name (car l))
	       (find-child-named name (cdr l))))))

(defgeneric attach (obj parent))
(defgeneric dettach (obj parent))

;(defmethod attach ((tex texture-arb) (s spatial))
;  (pushnew tex (effects s)))

(defmethod attach ((obj spatial) (r renderer))
  (attach obj (renderer-scene r)))

(defmethod attach ((obj spatial) (n node))
  (setf (part-of obj) n)
  (when (slot-boundp n 'view)
    (setf (view obj) (view n)))
  (pushnew obj (children n)))

(defmethod update-world-data :after ((n node) app-time)
  (when *debug-update-pass* (format t "Update-world-data (node): ~A~%" (name n)))
  (dolist (child (children n))
    (update-geometric-state child app-time nil)))

(defmethod update-world-bound ((n node))
  (when *debug-update-pass* (format t "Update-world-bound (node): ~A~%" (name n)))
  (with-slots (bound-is-current-p b_w) n
    (unless bound-is-current-p
      (let ((found-first-bound-p nil))
	(dolist (child (children n))
	  (cond (found-first-bound-p (setf b_w
					   (grow-to-contain b_w (bounding-volume child))))
		(t (setf found-first-bound-p t
			 b_w (copy-bound (bounding-volume child))))))
	(setf (bound-is-current-p n) t)))))

;;; Geometry ;;;

(defgeneric update-model-state (geometry &optional update-normals-p))
(defgeneric update-model-bound (geometry))
(defgeneric update-model-normals (geometry))
(defgeneric initialize-data (geometry renderer))

(defmethod initialize-data :around ((g geometry) r)
  (declare (ignore r))
  (call-next-method)
  (when (or (not (slot-boundp g 'v)) (null (bounding-volume g)))
    (setf (bounding-volume g) (compute-bound-from-data 'bounding-sphere (vertices g))))
  (update-vertex-attrib-object g))


(defmethod update-world-bound ((g geometry))
  (when *debug-update-pass* (format t "Update-world-bound (geometry): ~A~%" (name g)))
  (unless (bound-is-current-p g)
    (setf (bounding-volume g) (transform-bound-by (bounding-volume g) (transform g)))))


(defmethod update-vertex-attrib-object ((g trimesh))
  (when (vertex-attrib-object-format g)
    (with-slots (v c n i tc vao-format vao) g
      (if vao
	  (gllib::delete-vertex-list vao))
      (setf vao (gllib:new-vertex-list :format vao-format
				       :data (list v c tc)
				       :indices i
				       :mode :triangles)))))

;;; XML ;;;

(defmethod xml::add-subobject ((n node) (s spatial))
  (attach s n))

(defmethod xml::add-subobject ((s spatial) obj)
  (error "Attempting to attach ~a to spatial ~A.  Objects of type Spatial cannot contain sub-objects.  Use a Node object instead." s obj))

;;;; Trimesh Geometries ;;;;

(defmethod vertex-count ((mesh trimesh))
  (/ (element-count (vertices mesh)) 3))

(defmethod triangle-count ((mesh trimesh))
  (/ (element-count (indices mesh)) 3))

(defmethod get-vertex ((mesh trimesh) idx)
  (with-slots (v) mesh
    (vector (aref v (* 3 idx))
	    (aref v (1+ (* 3 idx)))
	    (aref v (+ 2 (* 3 idx))))))

(defmethod get-triangle ((mesh trimesh) idx)
  (with-slots (i) mesh
    (list (get-vertex mesh (aref i (* idx 3)))
	  (get-vertex mesh (aref i (1+ (* idx 3))))
	  (get-vertex mesh (aref i (+ 2 (* idx 3)))))))



;;;; Tests ;;;;

(defun scene-setup-1 ()
  (let* ((h (make-instance 'node :name "House"))
	 (r1 (make-instance 'node :name "Room 1"))
	 (r2 (make-instance 'node :name "Room 2"))
	 (tg (make-instance 'node :name "Table Group"))
	 (c (make-instance 'geometry :name "Chair"))
	 (tab (make-instance 'geometry :name "Table"))
	 (ug (make-instance 'node :name "Utensil Group"))
	 (p (make-instance 'geometry :name "Plate"))
	 (k (make-instance 'geometry :name "Knife"))
	 (f (make-instance 'geometry :name "Fork")))
    (attach r1 h)
    (attach r2 h)
    (attach tg r1)
    (attach c r1)
    (attach tab tg)
    (attach ug tg)
    (attach p ug)
    (attach k ug)
    (attach f ug)
    h))

(defun test-find-node ()
  (let ((h (scene-setup-1)))
    (assert (equal (find-child-named "House" h) h))
    (format t "~A~%" (name (find-child-named "Room 1" h)))
    (format t "~A~%" (name (find-child-named "Room 2" h)))
    (format t "~A~%" (name (find-child-named "Fork" h)))))

(defun test-gs-update ()
  (let* ((h (make-instance 'node :name "House"))
	 (r1 (make-instance 'node :name "Room 1"))
	 (r2 (make-instance 'node :name "Room 2"))
	 (tg (make-instance 'node :name "Table Group"))
	 (c (make-instance 'geometry :name "Chair"))
	 (tab (make-instance 'geometry :name "Table"))
	 (ug (make-instance 'node :name "Utensil Group"))
	 (p (make-instance 'geometry :name "Plate"))
	 (k (make-instance 'geometry :name "Knife"))
	 (f (make-instance 'geometry :name "Fork")))
    (attach r1 h)
    (attach r2 h)
    (attach tg r1)
    (attach c r1)
    (attach tab tg)
    (attach ug tg)
    (attach p ug)
    (attach k ug)
    (attach f ug)
    (update-geometric-state r1 0 t)
    h))

(defun test-gs-update-2 ()
  (let ((h (slui (:node :name "N0"
			(:node :name "N1"
			       (:geometry :name "G3")
			       (:node :name "N4"
				      (:geometry :name "G5")
				      (:geometry :name "G6")))
			(:node :name "n2")))))
    (update-geometric-state (find-child-named "N1" h) 0 t)))

(defun test-rs-update ()
  (let ((scene (test-gs-update)))
    (update-render-state scene nil nil)
    scene))

(defun test-rs-update-2 ()
  (let ((obj (make-instance 'geometry :name "Geometry")))
    (push-state obj (make-default-rs-stack) (make-list 1))
    obj))
